home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HAM Radio 1997
/
HAM Radio 1997.iso
/
vcls
/
picklist
/
picklist.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-04-08
|
9KB
|
353 lines
unit Picklist;
{Copyright 1995 by Robert Fabiszak
Free unrestricted use granted provided this copyright notice
is maintained.
PICKLIST is an enhanced list box control for Borland's Delphi
product. Version 1.0. June, 1995}
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, menus;
type
TSelectedStyle = (psStandard, psCheckbox, psBoldText, psOwnerDraw);
PTabArray = ^TTabArray;
TTabArray = array[0..0] of integer;
EInvalidTabStop = exception;
TPickList = class(TCustomListBox)
private
{ Private declarations }
FUseTabs: boolean;
FSelectedStyle: TSelectedStyle;
FOnChange : TNotifyEvent;
FLastSel : integer;
FTabStops: TStrings;
procedure Click; override;
protected
{ Protected declarations }
procedure SetUseTabStops(bUseTabs: boolean);
procedure SetSelectedStyle(AStyle: TSelectedStyle);
procedure CreateParams(var Params: TCreateParams); override;
procedure Change; virtual;
procedure DrawCheckboxStyle(Index: integer; Rect: TRect;
State: TOwnerDrawState);
procedure DrawBoldStyle(Index: integer; Rect: TRect;
State: TOwnerDrawState);
function GetTabStops: string;
procedure SetTabStops(sTabStops: string);
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy;
procedure SelectAll;
procedure ClearSelection;
procedure DrawItem(Index: integer; Rect: TRect; State: TOwnerDrawState);
override;
published
{ Published declarations }
property Align;
property BorderStyle;
property Color;
property Columns;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property ExtendedSelect;
property Font;
property IntegralHeight;
property ItemHeight;
property Items;
property MultiSelect;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Sorted;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnDrawItem;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMeasureItem;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
{custom extensions}
property UseTabStops: boolean read FUseTabs write SetUseTabStops
default True;
property SelectedStyle: TSelectedStyle read FSelectedStyle
write SetSelectedStyle default psCheckbox;
{NOTE: TabStops property measured in terms of average character widths}
property TabStops: string read GetTabStops write SetTabStops;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register;
implementation
constructor TPickList.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Style := lbOwnerDrawFixed;
FLastSel := -1;
FUseTabs := True;
FSelectedStyle := psCheckbox;
FTabStops := TStringList.Create;
end;
destructor TPickList.Destroy;
begin
FTabStops.Free;
end;
procedure TPickList.SetUseTabStops(bUseTabs: boolean);
begin
if FUseTabs <> bUseTabs then
begin
FUseTabs := bUseTabs;
Invalidate
end;
end;
procedure TPickList.SetSelectedStyle(AStyle: TSelectedStyle);
begin
if FSelectedStyle <> AStyle then
begin
FSelectedStyle := AStyle;
if AStyle = psStandard then
Style := lbStandard
else
Style := lbOwnerDrawFixed;
Invalidate;
end;
end;
procedure TPickList.Change;
begin
FLastSel := ItemIndex;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TPickList.Click;
begin
inherited Click;
if FLastSel <> ItemIndex then
Change;
end;
procedure TPickList.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
if FUseTabs then
with Params do Style := Style or LBS_USETABSTOPS;
end;
procedure TPickList.SelectAll;
begin
if MultiSelect or ExtendedSelect then
SendMessage(Handle, LB_SETSEL, 1, -1);
end;
procedure TPickList.ClearSelection;
begin
if MultiSelect or ExtendedSelect then
SendMessage(Handle, LB_SETSEL, 0, -1);
end;
procedure TPickList.DrawItem(Index: integer; Rect: TRect; State:
TOwnerDrawState);
begin
case FSelectedStyle of
psCheckbox: DrawCheckboxStyle(Index, Rect, State);
psBoldText: DrawBoldStyle(Index, Rect, State);
psStandard, psOwnerDraw: inherited DrawItem(Index, Rect, State);
end;
end;
procedure TPickList.DrawCheckboxStyle(Index: integer; Rect: TRect;
State: TOwnerDrawState);
var
ch: array[0..255] of char;
TabArray: PTabArray;
i: integer;
nTab: integer;
Metrics: TTextMetric;
begin
GetTextMetrics(Canvas.Handle, Metrics);
GetMem(TabArray, FTabStops.Count * sizeof(integer));
try
for i := 0 to FTabStops.Count - 1 do
begin
try
nTab := StrToInt(FTabStops[i]); {if any non-integers, we'll raise exception}
except
on EConvertError do
raise EInvalidTabStop.Create(FTabStops[i] + ' is an invalid tab stop');
end;
{convert tab stops from avg. character widths to device units}
TabArray^[i] := nTab * Metrics.tmAveCharWidth;
end;
with Canvas do
begin
Brush.Color := Color;
FillRect(Rect);
{manually set these colors to override the color change when
the item is focused}
Font.Color := self.Font.Color;
Pen.Color := self.Font.Color;
Rectangle(Rect.Left + 2, Rect.Top + 1, Rect.Left + ItemHeight,
Rect.Top + ItemHeight - 1);
if odSelected in State then
begin
MoveTo(Rect.Left + 2, Rect.Top + 1);
LineTo(Rect.Left + ItemHeight, Rect.Top + ItemHeight - 1);
MoveTo(Rect.Left + ItemHeight - 1, Rect.Top + 1);
LineTo(Rect.Left + 1, Rect.Top + ItemHeight - 1);
end;
if FUseTabs then
TabbedTextOut(Handle, Rect.Left + ItemHeight + 4, Rect.Top,
StrPCopy(ch, Items[Index]), Length(Items[Index]), FTabStops.Count,
TabArray^, 0)
else
TextOut(Rect.Left + ItemHeight + 4, Rect.Top, Items[Index]);
end;
finally
FreeMem(TabArray, FTabStops.Count * sizeof(integer));
end;
end;
procedure TPickList.DrawBoldStyle(Index: integer; Rect: TRect;
State: TOwnerDrawState);
var
ch: array[0..255] of char;
TabArray: PTabArray;
i: integer;
Metrics: TTextMetric;
nTab: integer;
begin
GetTextMetrics(Canvas.Handle, Metrics);
GetMem(TabArray, FTabStops.Count * sizeof(integer));
try
for i := 0 to FTabStops.Count - 1 do
begin
try
nTab := StrToInt(FTabStops[i]); {if any non-integers, we'll raise exception}
except
on EConvertError do
raise EInvalidTabStop.Create(FTabStops[i] + ' is an invalid tab stop');
end;
{convert tab stops from avg. character widths to device units}
TabArray^[i] := nTab * Metrics.tmAveCharWidth;
end;
with Canvas do
begin
Brush.Color := Color;
FillRect(Rect);
{manually set these colors to override the color change when
the item is focused}
Font.Color := self.Font.Color;
Pen.Color := self.Font.Color;
if odSelected in State then
Font.Style := Font.Style + [fsBold]
else
Font.Style := Font.Style - [fsBold];
if FUseTabs then
TabbedTextOut(Handle, Rect.Left + 2, Rect.Top, StrPCopy(ch, Items[Index]),
Length(Items[Index]), FTabStops.Count, TabArray^, 0)
else
TextOut(Rect.Left + 2, Rect.Top, Items[Index]);
end;
finally
FreeMem(TabArray, FTabStops.Count * sizeof(integer));
end;
end;
function TPickList.GetTabStops: string;
var
i: integer;
begin
Result := '';
for i := 0 to FTabStops.Count - 1 do
begin
Result := Result + FTabStops[i];
if i < FTabStops.Count - 1 then
Result := Result + ';';
end;
end;
procedure TPickList.SetTabStops(sTabStops: string);
var
sTemp: string;
i: integer;
nTab: integer;
begin
FTabStops.Clear; {get rid of current tab stops}
if Length(sTabStops) = 0 then
Exit; {we're clearing the tab stops}
sTemp := '';
for i := 1 to Length(sTabStops) do
begin
if (sTabStops[i] = ';') and (i > 1) then
begin
try
nTab := StrToInt(sTemp); {if any non-integers, we'll raise exception}
except
on EConvertError do
raise EInvalidTabStop.Create(sTemp + ' is an invalid tab stop');
end;
FTabStops.Add(sTemp);
sTemp := '';
end
else
sTemp := sTemp + sTabStops[i];
end;
{now make sure we add the final token}
try
nTab := StrToInt(sTemp); {if any non-integers, we'll raise exception}
except
on EConvertError do
raise EInvalidTabStop.Create(sTemp + ' is an invalid tab stop');
end;
FTabStops.Add(sTemp);
Invalidate;
end;
procedure Register;
begin
RegisterComponents('Extensions', [TPickList]);
end;
end.